home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / base.scm < prev    next >
Text File  |  1995-10-13  |  10KB  |  381 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file base.scm.
  6.  
  7. ;;;; Fundamental definitions
  8.  
  9. ; Order of appearance is approximately that of the Revised^4 Report.
  10.  
  11. ; Booleans
  12.  
  13. (define (not x) (if x #f #t))
  14. (define (boolean? x) (or (eq? x #t) (eq? x #f)))
  15.  
  16. ; Equality
  17.  
  18. (define (eqv? x y)
  19.   (or (eq? x y)
  20.       (and (number? x)
  21.            (number? y)
  22.            (eq? (exact? x) (exact? y))
  23.            (= x y))))
  24.  
  25. (define (equal? obj1 obj2)
  26.   (cond ((eqv? obj1 obj2) #t)
  27.         ((pair? obj1)
  28.          (and (pair? obj2)
  29.               (equal? (car obj1) (car obj2))
  30.               (equal? (cdr obj1) (cdr obj2))))
  31.         ((string? obj1)
  32.          (and (string? obj2)
  33.               (string=? obj1 obj2)))
  34.         ((vector? obj1)
  35.          (and (vector? obj2)
  36.               (let ((z (vector-length obj1)))
  37.                 (and (= z (vector-length obj2))
  38.                      (let loop ((i 0))
  39.                        (cond ((= i z) #t)
  40.                              ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
  41.                               (loop (+ i 1)))
  42.                              (else #f)))))))
  43.         (else #f)))
  44.  
  45. ; Simple number stuff
  46.  
  47. (define (> x y) (< y x))
  48. (define (<= x y) (not (< y x)))
  49. (define (>= x y) (not (< x y)))
  50.  
  51. (define (max first . rest)
  52.   (reduce (lambda (x y) (if (< x y) y x))
  53.       first
  54.       rest))
  55. (define (min first . rest)
  56.   (reduce (lambda (x y) (if (< x y) x y))
  57.       first
  58.       rest))
  59.  
  60. (define (abs n) (if (< n 0) (- 0 n) n))
  61.  
  62. (define (zero? x) (= x 0))
  63. (define (positive? x) (< 0 x))
  64. (define (negative? x) (< x 0))
  65.  
  66. (define (even? n) (= 0 (remainder n 2)))
  67. (define (odd? n) (not (even? n)))
  68.  
  69. ; Lists
  70.  
  71. (define (caar   x) (car (car x)))
  72. (define (cadr   x) (car (cdr x)))
  73. (define (cdar   x) (cdr (car x)))
  74. (define (cddr   x) (cdr (cdr x)))
  75.  
  76. (define (caaar  x) (caar (car x)))
  77. (define (caadr  x) (caar (cdr x)))
  78. (define (cadar  x) (cadr (car x)))
  79. (define (caddr  x) (cadr (cdr x)))
  80. (define (cdaar  x) (cdar (car x)))
  81. (define (cdadr  x) (cdar (cdr x)))
  82. (define (cddar  x) (cddr (car x)))
  83. (define (cdddr  x) (cddr (cdr x)))
  84.  
  85. (define (caaaar x) (caaar (car x)))
  86. (define (caaadr x) (caaar (cdr x)))
  87. (define (caadar x) (caadr (car x)))
  88. (define (caaddr x) (caadr (cdr x)))
  89. (define (cadaar x) (cadar (car x)))
  90. (define (cadadr x) (cadar (cdr x)))
  91. (define (caddar x) (caddr (car x)))
  92. (define (cadddr x) (caddr (cdr x)))
  93. (define (cdaaar x) (cdaar (car x)))
  94. (define (cdaadr x) (cdaar (cdr x)))
  95. (define (cdadar x) (cdadr (car x)))
  96. (define (cdaddr x) (cdadr (cdr x)))
  97. (define (cddaar x) (cddar (car x)))
  98. (define (cddadr x) (cddar (cdr x)))
  99. (define (cdddar x) (cdddr (car x)))
  100. (define (cddddr x) (cdddr (cdr x)))
  101.  
  102. (define (null? x) (eq? x '()))
  103.  
  104. (define (list . l) l)
  105.  
  106. (define (length l)
  107.   (reduce (lambda (ignore n) (+ n 1)) 0 l))
  108.  
  109. (define (append . lists)
  110.   (if (null? lists)
  111.       '()
  112.       (let recur ((lists lists))
  113.     (if (null? (cdr lists))
  114.         (car lists)
  115.         (reduce cons (recur (cdr lists)) (car lists))))))
  116.  
  117. (define (reverse list)
  118.   (append-reverse list '()))
  119.  
  120. (define (append-reverse list seed)
  121.   (if (null? list)
  122.       seed
  123.       (append-reverse (cdr list) (cons (car list) seed))))
  124.  
  125. (define (list-tail l i)
  126.   (cond ((= i 0) l)
  127.     (else (list-tail (cdr l) (- i 1)))))
  128.  
  129. (define (list-ref l k)
  130.   (car (list-tail l k)))
  131.  
  132. (define (mem pred)
  133.   (lambda (obj l)
  134.     (let loop ((l l))
  135.       (cond ((null? l) #f)
  136.         ((pred obj (car l)) l)
  137.         (else (loop (cdr l)))))))
  138.  
  139. (define memq   (mem eq?))
  140. (define memv   (mem eqv?))
  141. (define member (mem equal?))
  142.  
  143. (define (ass pred)
  144.   (lambda (obj l)
  145.     (let loop ((l l))
  146.       (cond ((null? l) #f)
  147.             ((pred obj (caar l)) (car l))
  148.             (else (loop (cdr l)))))))
  149.  
  150. ;(define assq  (ass eq?))
  151. (define assv  (ass eqv?))
  152. (define assoc (ass equal?))
  153.  
  154. ; Bummed version.  Pretend that you didn't see this.
  155.  
  156. (define (assq x l)
  157.   (cond ((null? l) #f)
  158.     ((eq? x (caar l)) (car l))
  159.     (else (assq x (cdr l)))))
  160.  
  161. (define (list? l)            ;New in R4RS
  162.   (let recur ((l l) (lag l))        ;Cycle detection
  163.     (or (null? l)
  164.     (and (pair? l)
  165.          (or (null? (cdr l))
  166.          (and (pair? (cdr l))
  167.               (not (eq? (cdr l) lag))
  168.               (recur (cddr l) (cdr lag))))))))
  169.  
  170. ; Characters
  171.  
  172. (define (char>? x y) (char<? y x))
  173. (define (char>=? x y) (not (char<? x y)))
  174. (define (char<=? x y) (not (char>? x y)))
  175.  
  176. (define (char-whitespace? c)
  177.   (if (memq (char->ascii c) ascii-whitespaces) #t #f))
  178.  
  179. (define (char-lower-case? c)
  180.   (and (char>=? c #\a)
  181.        (char<=? c #\z)))
  182.  
  183. (define (char-upper-case? c)
  184.   (and (char>=? c #\A)
  185.        (char<=? c #\Z)))
  186.  
  187. (define (char-numeric? c)
  188.   (and (char>=? c #\0)
  189.        (char<=? c #\9)))
  190.  
  191. (define (char-alphabetic? c)
  192.   (or (char-upper-case? c)
  193.       (char-lower-case? c)))
  194.  
  195. (define char-case-delta 
  196.   (- (char->ascii #\a) (char->ascii #\A)))
  197.  
  198. (define (char-upcase c)
  199.   (if (char-lower-case? c)
  200.       (ascii->char (- (char->ascii c) char-case-delta))
  201.       c))
  202.  
  203. (define (char-downcase c)
  204.   (if (char-upper-case? c)
  205.       (ascii->char (+ (char->ascii c) char-case-delta))
  206.       c))
  207.  
  208. (define (char-ci-compare pred)
  209.   (lambda (c1 c2) (pred (char-upcase c1) (char-upcase c2))))
  210. (define char-ci=? (char-ci-compare char=?))
  211. (define char-ci<? (char-ci-compare char<?))
  212. (define char-ci<=? (char-ci-compare char<=?))
  213. (define char-ci>? (char-ci-compare char>?))
  214. (define char-ci>=? (char-ci-compare char>=?))
  215.  
  216.  
  217. ; Strings
  218.  
  219. (define (string . rest)
  220.   (list->string rest))
  221.  
  222. (define (substring s start end)
  223.   (let ((new-string (make-string (- end start) #\space)))
  224.     (do ((i start (+ i 1))
  225.          (j 0 (+ j 1)))
  226.         ((= i end) new-string)
  227.       (string-set! new-string j (string-ref s i)))))
  228.  
  229. (define (string-append  . strings)
  230.   (let ((len (reduce (lambda (s n) (+ (string-length s) n)) 0 strings)))
  231.     (let ((new-string (make-string len #\space)))
  232.       (let loop ((s strings)
  233.          (i 0))
  234.     (if (null? s)
  235.         new-string
  236.         (let* ((string (car s))
  237.            (l (string-length string)))
  238.           (do ((j 0 (+ j 1))
  239.            (i i (+ i 1)))
  240.           ((= j l) (loop (cdr s) i))
  241.         (string-set! new-string i (string-ref string j)))))))))
  242.  
  243. (define (string->list v)
  244.   (let ((z (string-length v)))
  245.     (do ((i (- z 1) (- i 1))
  246.          (l '() (cons (string-ref v i) l)))
  247.         ((< i 0) l))))
  248.  
  249. (define (list->string l)
  250.   (let ((v (make-string (length l) #\space)))
  251.     (do ((i 0 (+ i 1))
  252.          (l l (cdr l)))
  253.         ((null? l) v)
  254.       (string-set! v i (car l)))))
  255.  
  256. ; comes from low-level package ...
  257. ;(define (string-copy s)
  258. ;  (let ((z (string-length s)))
  259. ;    (let ((copy (make-string z #\space)))
  260. ;      (let loop ((i 0))
  261. ;        (cond ((= i z) copy)
  262. ;              (else
  263. ;               (string-set! copy i (string-ref s i))
  264. ;               (loop (+ i 1))))))))
  265.  
  266. (define (string-fill! v x)
  267.   (let ((z (string-length v)))
  268.     (do ((i 0 (+ i 1)))
  269.         ((= i z) (unspecific))
  270.       (string-set! v i x))))
  271.  
  272. (define (make-string=? char=?)
  273.   (lambda (s1 s2)
  274.     (let ((z (string-length s1)))
  275.       (and (= z (string-length s2))
  276.        (let loop ((i 0))
  277.          (cond ((= i z) #t)
  278.            ((char=? (string-ref s1 i) (string-ref s2 i))
  279.             (loop (+ i 1)))
  280.            (else #f)))))))
  281.  
  282. ;(define string=?    (make-string=? char=?))  -- VM implements this
  283. (define string-ci=? (make-string=? char-ci=?))
  284.  
  285. (define (make-string<? char<? char=?)
  286.   (lambda (s1 s2)
  287.     (let ((z1 (string-length s1))
  288.       (z2 (string-length s2)))
  289.       (let ((z (min z1 z2)))
  290.     (let loop ((i 0))
  291.       (if (= i z)
  292.           (< z1 z2)
  293.           (let ((c1 (string-ref s1 i))
  294.             (c2 (string-ref s2 i)))
  295.         (or (char<? c1 c2)
  296.             (and (char=? c1 c2)
  297.              (loop (+ i 1)))))))))))
  298.  
  299. (define string<?    (make-string<? char<? char=?))
  300. (define string-ci<? (make-string<? char-ci<? char-ci=?))
  301.  
  302. (define (string>? s1 s2) (string<? s2 s1))
  303. (define (string<=? s1 s2) (not (string>? s1 s2)))
  304. (define (string>=? s1 s2) (not (string<? s1 s2)))
  305.  
  306. (define (string-ci>? s1 s2) (string-ci<? s2 s1))
  307. (define (string-ci<=? s1 s2) (not (string-ci>? s1 s2)))
  308. (define (string-ci>=? s1 s2) (not (string-ci<? s1 s2)))
  309.  
  310. ; Vectors
  311.  
  312. (define (vector . l)
  313.   (list->vector l))
  314.  
  315. (define (vector->list v)
  316.   (do ((i (- (vector-length v) 1) (- i 1))
  317.        (l '() (cons (vector-ref v i) l)))
  318.       ((< i 0) l)))
  319.  
  320. (define (list->vector l)
  321.   (let ((v (make-vector (length l) #f)))
  322.     (do ((i 0 (+ i 1))
  323.          (l l (cdr l)))
  324.         ((null? l) v)
  325.       (vector-set! v i (car l)))))
  326.  
  327. (define (vector-fill! v x)
  328.   (let ((z (vector-length v)))
  329.     (do ((i 0 (+ i 1)))
  330.         ((= i z) (unspecific))
  331.       (vector-set! v i x))))
  332.  
  333. ; Control features
  334.  
  335. (define (map proc first . rest)
  336.   (if (null? rest)
  337.       (map1 proc first)
  338.       (map2+ proc first rest)))
  339.  
  340. (define (map1 proc l)
  341.   ;; (reduce (lambda (x l) (cons (proc x) l)) '() l)
  342.   (if (null? l)
  343.       '()
  344.       (cons (proc (car l)) (map1 proc (cdr l)))))
  345.  
  346. (define (map2+ proc first rest)
  347.   (if (or (null? first)
  348.       (any null? rest))
  349.       '()
  350.       (cons (apply proc (cons (car first) (map1 car rest)))
  351.         (map2+ proc (cdr first) (map1 cdr rest)))))
  352.  
  353. (define (for-each proc first . rest)
  354.   (let loop ((first first) (rest rest))
  355.     (if (or (null? first)
  356.         (any null? rest))
  357.     (unspecific)
  358.     (begin (apply proc (cons (car first) (map car rest)))
  359.            (loop (cdr first) (map cdr rest))))))
  360.  
  361.  
  362. ; Promises.
  363.  
  364. (define-syntax delay
  365.   (syntax-rules ()
  366.     ((delay ?exp) (make-promise (lambda () ?exp)))))
  367.  
  368. (define (make-promise thunk-then-result)
  369.   (let ((already-run? #f)
  370.     (started? #f))
  371.     (lambda ()
  372.       (cond ((not already-run?)
  373.          (if started? (warn "recursive force" thunk-then-result))
  374.          (set! started? #t)
  375.              (set! thunk-then-result (thunk-then-result))
  376.              (set! already-run? #t)))
  377.       thunk-then-result)))
  378.  
  379. (define (force promise)
  380.   (promise))
  381.